* $pp$PARLEN=48
C---------------------------------------------------------
C    TOOLPACK/1    Release: 3.1
C---------------------------------------------------------
C
C       I S T P 2   -   P R O G R A M   P A R A M E T E R S
C       ---------       -------------   -------------------
C
C       (Monolithic Version)
C
C       This program processes a source file (at the token stream level)
C       looking for $pp$ source-embedded directives.
C
C       A $pp$ SED defines a program-wide parameter.  ISTPP then looks
C       through the rest of the program for PARAMETER statements which
C       mention this name, and ensures that they all have the correct
C       value.
C
C       There is also a facility for including a "library" file which
C       contains SED's only (not a token stream).
C

      PROGRAM ISTP2

      INTEGER MINUS,EOS,MAXPTH,READ,ERR,EOF,NO,STDERR,OK,WRITE,STDOUT
      PARAMETER (MINUS=45,EOS=129,MAXPTH=81,READ=0,ERR=-1,EOF=-100,
     +          NO=-3,STDERR=2,OK=-2,WRITE=1,STDOUT=1)

      INTEGER SRCPTH(MAXPTH),OUTPTH(MAXPTH),LIBPTH(MAXPTH),IODSRC,
     +        IODOUT,IODLIB,TKIDES,TKODES,NOLIB(2)
      LOGICAL ASKUSR

      INTEGER GETARG,OPEN,CREATE,ZTKGTI,ZTKPTI,EQUAL
      EXTERNAL GETARG,OPEN,CREATE,ZTKGTI,ZTKPTI,EQUAL,ZINIT,ZQUIT,ERROR,
     +         ZMESS

      DATA NOLIB/MINUS,EOS/

      CALL ZINIT

      IF (GETARG(1,SRCPTH,MAXPTH).EQ.EOF) CALL PPARGS(1,SRCPTH)
      IODSRC = OPEN(SRCPTH,READ)
      IF (IODSRC.EQ.ERR) CALL ERROR('Can''t open source file')
      IF (GETARG(2,OUTPTH,MAXPTH).EQ.EOF) CALL PPARGS(2,OUTPTH)
      IODOUT = CREATE(OUTPTH,WRITE)
      IF (IODOUT.EQ.ERR) CALL ERROR('Can''t create output file')
      ASKUSR = GETARG(3,LIBPTH,MAXPTH) .EQ. EOF
      IF (ASKUSR) THEN
          CALL ZMESS('Input library filenames, end with bla'//'nk line',
     +               STDOUT)
          CALL PPARGS(3,LIBPTH)
      END IF

      IF (EQUAL(LIBPTH,NOLIB).EQ.NO .AND. LIBPTH(1).NE.EOS) THEN
          IODLIB = OPEN(LIBPTH,READ)
          IF (IODLIB.EQ.ERR) CALL ERROR('Can''t open library input')

      ELSE
          IODLIB = -1
      END IF

      TKIDES = ZTKGTI(0,IODSRC,ERR)
      TKODES = ZTKPTI(0,IODOUT,ZTKGTI(2,0,0))

      CALL PPMAIN(TKIDES,TKODES,IODLIB,ASKUSR)

      CALL ZMESS('[ISTP2 Normal Termination]',STDERR)
      CALL ZQUIT(OK)

      END
C ----------------------------------------------------------------------
C
C       P P A R G S   -   Input ISTPP command arguments from user
C

      SUBROUTINE PPARGS(N,PATH)

      INTEGER MAXPTH
      PARAMETER (MAXPTH=81)

      INTEGER N,PATH(MAXPTH)

      INTEGER BIGI,LETP,LETU,LETT,BLANK,LETO,LETE,LETN,LETS,LETR,LETA,
     +        COLON,EOS,LETC,LETF,LETI,LETL,BIGO,LETB,STDIN,LETY
      PARAMETER (BIGI=73,LETN=110,LETP=112,LETU=117,LETT=116,BLANK=32,
     +          LETO=111,LETE=101,LETS=115,LETR=114,LETA=97,COLON=58,
     +          EOS=129,LETC=99,LETF=102,LETI=105,LETL=108,BIGO=79,
     +          LETB=98,STDIN=0,LETY=121)

      INTEGER I,PROMPT(21,3)

      SAVE PROMPT

      INTEGER ZGTCMD
      EXTERNAL ZGTCMD,ZPRMPT

C "Input source file: "
C "Output file: "
C "Input library file: "

      DATA (PROMPT(I,1),I=1,20)/BIGI,LETN,LETP,LETU,LETT,BLANK,LETS,
     +     LETO,LETU,LETR,LETC,LETE,BLANK,LETF,LETI,LETL,LETE,COLON,
     +     BLANK,EOS/
      DATA (PROMPT(I,2),I=1,14)/BIGO,LETU,LETT,LETP,LETU,LETT,BLANK,
     +     LETF,LETI,LETL,LETE,COLON,BLANK,EOS/
      DATA (PROMPT(I,3),I=1,21)/BIGI,LETN,LETP,LETU,LETT,BLANK,LETL,
     +     LETI,LETB,LETR,LETA,LETR,LETY,BLANK,LETF,LETI,LETL,LETE,
     +     COLON,BLANK,EOS/

      CALL ZPRMPT(PROMPT(1,N))
      I = ZGTCMD(PATH,STDIN)

      END
C ----------------------------------------------------------------------
C
C       P P M A I N   -   ISTPP Main Processing
C

      SUBROUTINE PPMAIN(TKIDES,TKODES,IODLIB,ASKUSR)
      INTEGER TKIDES,TKODES,IODLIB
      LOGICAL ASKUSR

      INTEGER MAXTLN,MAXBUF,PERCNT,LETI,LETN,LETC,LETL,LETU,LETD,LETE,
     +        BLANK,PLUS,LESS,QMARK,GREATR,DOLLAR,EOS,AND,DIG1,ERR,STAR,
     +        YES,LETP,OK,STDERR,BIGI,READ,MAXPRM,MAXPTH,EOF,TNAME,
     +        TCOMMA,TRPARN,TEQUAL,TCMMNT,TPARAM,TZEOF,TZEOS
      PARAMETER (MAXTLN=1322,MAXBUF=134,PERCNT=37,LETI=105,LETN=110,
     +          LETC=99,LETL=108,LETU=117,LETD=100,LETE=101,BLANK=32,
     +          PLUS=43,QMARK=63,GREATR=62,DOLLAR=36,EOS=129,AND=38,
     +          DIG1=49,ERR=-1,STAR=42,YES=-2,LETP=112,OK=-2,STDERR=2,
     +          BIGI=73,READ=0,MAXPRM=10,MAXPTH=81,EOF=-100,TNAME=76,
     +          TCOMMA=48,TRPARN=52,TEQUAL=49,TPARAM=28,TZEOF=1,
     +          TZEOS=79,LESS=60,TCMMNT=80)

      INTEGER PARLEN
      PARAMETER (PARLEN=48)

      INTEGER MAXPAR,MAXINC
      PARAMETER (MAXPAR=500,MAXINC=3)

      INTEGER NPARMS,TOKTYP,TOKLEN,TOKTXT(MAXTLN),STATUS,BIND,ID(3),
     +        BODY(MAXBUF),LHS(MAXBUF),RHS(MAXBUF),INCDEP,
     +        RESULT(MAXBUF),IODINC(MAXINC),PATTRN(16),REPLCE(3),PARNUM
      LOGICAL INPARA
      CHARACTER*(PARLEN) PTABLE(2,MAXPAR)

      LOGICAL LOOKUP

      INTEGER ZSEDID,ZSPLIT,LENGTH,ZGTCMD,ZPREPL,ZSETR,ZSETP,OPEN,GETARG
      EXTERNAL ZSEDID,ZSPLIT,LENGTH,ZGTCMD,ZPREPL,ZSETR,ZSETP,OPEN,
     +         GETARG,ZSCAN,ZUSCAN,ERROR,ZMESS,PUTLIN,ZCHOUT,CANT,ZPTMES

C PATTRN: "%include +<?+>$"
C REPLCE: "&1"

      DATA PATTRN/PERCNT,LETI,LETN,LETC,LETL,LETU,LETD,LETE,BLANK,PLUS,
     +     LESS,QMARK,PLUS,GREATR,DOLLAR,EOS/,REPLCE/AND,DIG1,EOS/

C
C Initialise
C
      NPARMS = 0
      INPARA = .FALSE.
      ID(1) = EOS
      ID(2) = 0
      INCDEP = 1
      IODINC(1) = IODLIB
      IF (ZSETP(PATTRN,.TRUE.).EQ.ERR) CALL ERROR('ZSETP failed')
      IF (ZSETR(REPLCE).EQ.ERR) CALL ERROR('ZSETR failed')
      PARNUM = 6
C
C Process library file if necessary
C
      IF (IODLIB.GE.0) THEN
  100     TOKLEN = ZGTCMD(TOKTXT,IODINC(INCDEP))
          IF (TOKLEN.EQ.ERR) CALL ERROR('PPMAIN: I/O ERROR')
          IF (TOKLEN.GE.0 .AND. TOKTXT(1).EQ.STAR) THEN
              STATUS = ZSEDID(TOKTXT,BIND,ID,BODY)
              IF (STATUS.EQ.YES .AND. ID(1).EQ.LETP .AND.
     +            ID(2).EQ.LETP) THEN
                  IF (ZSPLIT(BODY,LHS,RHS).NE.OK) THEN
                      CALL ZCHOUT('Erroneous ISTPP directive:',stderr)
                      CALL PUTLIN(BODY,stderr)
                      CALL ZMESS(' - ignored',stderr)

                  ELSE IF (NPARMS.EQ.MAXPAR) THEN
                      CALL ERROR('Too many parameters')

                  ELSE
                      CALL ENTER(LHS,PTABLE,NPARMS,MAXPAR,RHS)
                  END IF

              END IF

          ELSE IF (TOKLEN.GE.0 .AND. TOKTXT(1).EQ.LETI .OR.
     +             TOKTXT(1).EQ.BIGI) THEN
              IF (ZPREPL(TOKTXT,BODY,.FALSE.).EQ.ERR) THEN
                  CALL ZCHOUT('Invalid INCLUDE statement: ',STDERR)
                  CALL ZPTMES(TOKTXT,STDERR)

              ELSE IF (INCDEP.EQ.MAXINC) THEN
                  CALL ZCHOUT('Error in: ',STDERR)
                  CALL ZPTMES(TOKTXT,STDERR)
                  CALL ERROR('INCLUDE files too deeply nested')

              ELSE
                  INCDEP = INCDEP + 1
                  IODINC(INCDEP) = OPEN(BODY,READ)
                  IF (IODINC(INCDEP).EQ.ERR) THEN
                      CALL CANT(BODY)
                      CALL ERROR('ISTPP aborted')
                  END IF

              END IF

          END IF

          IF (TOKLEN.NE.eof) GO TO 100
C End of file - close it and decrement include nesting level
          CALL CLOSE(IODINC(INCDEP))
          INCDEP = INCDEP - 1
C Keep going until end of top level library file
          IF (INCDEP.GT.0) GO TO 100
          PARNUM = PARNUM + 1
C End of library file - see if we should do some more
          IF (PARNUM.LE.MAXPRM) THEN
              IF (ASKUSR) THEN
                  CALL PPARGS(3,BODY)

              ELSE IF (GETARG(PARNUM,BODY,MAXPTH).EQ.EOF) THEN
                  BODY(1) = EOS
              END IF

              IF (BODY(1).NE.EOS) THEN
                  INCDEP = 1
                  IODINC(INCDEP) = OPEN(BODY,READ)
                  IF (IODINC(INCDEP).NE.ERR) GO TO 100
                  CALL CANT(BODY)
                  CALL ERROR('ISTPP aborted')
              END IF

          END IF

      END IF
C
C Process input
C
  200 CALL ZSCAN(TOKTYP,TOKLEN,TOKTXT,TKIDES,STATUS)
      IF (STATUS.EQ.ERR .OR. STATUS.EQ.
     +    EOF) CALL ERROR('ZGETTK call failed')
      IF (TOKTYP.EQ.TCMMNT .AND. TOKTXT(1).EQ.STAR) THEN
          STATUS = ZSEDID(TOKTXT,BIND,ID,BODY)
          IF (STATUS.EQ.YES .AND. ID(1).EQ.LETP .AND.
     +        ID(2).EQ.LETP) THEN
              IF (ZSPLIT(BODY,LHS,RHS).NE.OK) THEN
                  CALL ZCHOUT('Erroneous ISTPP directive:',STDERR)
                  CALL PUTLIN(BODY,STDERR)
                  CALL ZMESS(' - ignored',STDERR)

              ELSE IF (NPARMS.EQ.MAXPAR) THEN
                  CALL ERROR('Too many parameters')

              ELSE
                  CALL ENTER(LHS,PTABLE,NPARMS,MAXPAR,RHS)
              END IF

          END IF

      ELSE IF (TOKTYP.EQ.TPARAM) THEN
          INPARA = .TRUE.

      ELSE IF (INPARA) THEN
          IF (TOKTYP.EQ.TZEOS) THEN
              INPARA = .FALSE.

          ELSE IF (TOKTYP.EQ.TNAME .AND. NPARMS.GT.0) THEN
              IF (LOOKUP(TOKTXT,PTABLE,NPARMS,RESULT)) THEN
                  CALL ZUSCAN(TOKTYP,TOKLEN,TOKTXT,TKODES)
                  CALL ZSCAN(TOKTYP,TOKLEN,TOKTXT,TKIDES,STATUS)
                  IF (TOKTYP.EQ.TEQUAL) THEN
                      CALL ZUSCAN(TOKTYP,TOKLEN,TOKTXT,TKODES)
                      CALL ZSCAN(TOKTYP,TOKLEN,TOKTXT,TKIDES,STATUS)
                      CALL ZUSCAN(TNAME,LENGTH(RESULT),RESULT,TKODES)
  300                 CALL ZSCAN(TOKTYP,TOKLEN,TOKTXT,TKIDES,STATUS)
                      IF (TOKTYP.EQ.TZEOS) CALL ERROR
     +                    ('Invalid PARAMETER statement')
                      IF (TOKTYP.NE.TCOMMA .AND.
     +                    TOKTYP.NE.TRPARN) GO TO 300
                  END IF

              END IF

          END IF

      END IF

      CALL ZUSCAN(TOKTYP,TOKLEN,TOKTXT,TKODES)
      IF (TOKTYP.NE.TZEOF) GO TO 200

      END
C ----------------------------------------------------------------------
C
C       E N T E R   -   Enter a parameter definition into the table
C

      SUBROUTINE ENTER(IPNAME,PTABLE,NPARMS,MAXPAR,IPDEFN)

      INTEGER STDERR
      PARAMETER (STDERR=2)

      INTEGER PARLEN
      PARAMETER (PARLEN=48)

      INTEGER IPNAME(*),NPARMS,MAXPAR,IPDEFN(*)
      CHARACTER*(PARLEN) PTABLE(2,MAXPAR)

      INTEGER NAMLEN,I
      CHARACTER*(PARLEN) PNAME,PDEFN

      INTEGER LENGTH
      EXTERNAL LENGTH,ZCHOUT,PUTLIN,ZMESS,ZTOCAP,ZITOF

      NAMLEN = LENGTH(IPNAME)
      IF (NPARMS.EQ.MAXPAR) THEN
          CALL ERROR('Too many parameters')

      ELSE IF (NAMLEN.GE.PARLEN) THEN
          CALL ZCHOUT('Parameter name "',STDERR)
          CALL PUTLIN(IPNAME,STDERR)
          CALL ZMESS('" is too long',STDERR)
          CALL ERROR('ENTER: Fatal Error')

      ELSE IF (LENGTH(IPDEFN).GE.PARLEN) THEN
          CALL ZCHOUT('Parameter definition of "',STDERR)
          CALL PUTLIN(IPNAME,STDERR)
          CALL ZMESS('" is too long',STDERR)
          CALL ERROR('ENTER: Fatal Error')
      END IF

      CALL ZTOCAP(IPNAME)
      CALL ZITOF(IPNAME,1,PARLEN,PNAME,.FALSE.)
      CALL ZITOF(IPDEFN,1,PARLEN,PDEFN,.FALSE.)

      I = 1
  100 IF (I.LE.NPARMS) THEN
          IF (PNAME.EQ.PTABLE(1,I)) CALL ERROR('Parameter '//
     +        PNAME(:NAMLEN)//' duplicated')
          I = I + 1
          GO TO 100

      END IF

      NPARMS = NPARMS + 1
      PTABLE(1,NPARMS) = PNAME
      PTABLE(2,NPARMS) = PDEFN

      END
C ----------------------------------------------------------------------
C
C       L O O K U P   -   Look a parameter definition up in a table
C

      LOGICAL FUNCTION LOOKUP(IPNAME,PTABLE,NPARMS,IPDEFN)

      INTEGER EOS
      PARAMETER (EOS=129)

      INTEGER PARLEN
      PARAMETER (PARLEN=48)

      INTEGER NPARMS,IPNAME(*),IPDEFN(*)
      CHARACTER*(PARLEN) PTABLE(2,NPARMS)

      INTEGER I,J
      CHARACTER*(PARLEN) PNAME

      EXTERNAL ZITOF,ZFTOI,ZTOCAP

      CALL ZTOCAP(IPNAME)
      CALL ZITOF(IPNAME,1,PARLEN,PNAME,.FALSE.)
      DO 200 I = 1,NPARMS
          IF (PNAME.EQ.PTABLE(1,I)) THEN
              LOOKUP = .TRUE.
              CALL ZFTOI(PTABLE(2,I),1,PARLEN,IPDEFN,.FALSE.)
              DO 100 J = PARLEN,1,-1
                  IF (PTABLE(2,I) (J:J).NE.' ') RETURN
                  IPDEFN(J) = EOS
  100         CONTINUE
              RETURN

          END IF

  200 CONTINUE
      LOOKUP = .FALSE.

      END
